Aminet 1

home *** CD-ROM | disk | FTP | other *** search

/ Aminet 1 / Aminet - June 1993 [Walnut Creek].iso / usenet / sources / volume90 / aplictns / xscheme2 / part03 < prev next >

Wrap

Internet Message Format | 1990-04-14 | 59.8 KB

Path: xanth!cs.odu.edu!Amiga-Request From: Amiga-Request@cs.odu.edu (Amiga Sources/Binaries Moderator) Newsgroups: comp.sources.amiga Subject: v90i141: XScheme 0.20 - an object-oriented scheme, Part03/07 Message-ID: <12211@xanth.cs.odu.edu> Date: 14 Apr 90 21:10:25 GMT Sender: tadguy@cs.odu.edu Reply-To: rusty@fe2o3.UUCP (Rusty Haddock) Lines: 2332 Approved: tadguy@cs.odu.edu (Tad Guy) X-Mail-Submissions-To: Amiga@cs.odu.edu X-Post-Discussions-To: comp.sys.amiga Submitted-by: rusty@fe2o3.UUCP (Rusty Haddock) Posting-number: Volume 90, Issue 141 Archive-name: applications/xscheme-0.20/part03 #!/bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh <file", e.g.. If this archive is complete, you # will see the following message at the end: # "End of archive 3 (of 7)." # Contents: Src/xscheme.h Src/xsdmem.c Src/xsftab.c Src/xsmath.c # Wrapped by tadguy@xanth on Sat Apr 14 17:07:24 1990 PATH=/bin:/usr/bin:/usr/ucb ; export PATH if test -f 'Src/xscheme.h' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'Src/xscheme.h'\" else echo shar: Extracting \"'Src/xscheme.h'\" $13100 characters$ sed "s/^X//" >'Src/xscheme.h' <<'END_OF_FILE' X/* xscheme.h - xscheme definitions */ X/* Copyright (c) 1988, by David Michael Betz X All Rights Reserved X Permission is granted for unrestricted non-commercial use */ X X/* system specific definitions */ X#define AZTEC_AMIGA X X#include <stdio.h> X#include <ctype.h> X#include <setjmp.h> X X/* FORWARD type of a forward declaration () */ X/* LOCAL type of a local function (static) */ X/* AFMT printf format for addresses ("%x") */ X/* OFFTYPE number the size of an address (int) */ X/* FIXTYPE data type for fixed point numbers (long) */ X/* ITYPE fixed point input conversion routine type (long atol()) */ X/* ICNV fixed point input conversion routine (atol) */ X/* IFMT printf format for fixed point numbers ("%ld") */ X/* FLOTYPE data type for floating point numbers (float) */ X/* FFMT printf format for floating point numbers (%.15g) */ X X/* for the Lightspeed C compiler - Macintosh */ X#ifdef LSC X#define AFMT "%lx" X#define OFFTYPE long X#define NIL (void *)0 X#define MACINTOSH X#endif X X/* for the UNIX System V C compiler */ X#ifdef UNIX X#endif X X/* for the Aztec C compiler - Amiga */ X#ifdef AZTEC_AMIGA X#define AFMT "%lx" X#define OFFTYPE long X#define FLOTYPE double X#endif X X/* for the Mark Williams C compiler - Atari ST */ X#ifdef MWC X#define AFMT "%lx" X#define OFFTYPE long X#endif X X/* for the Microsoft C 5.0 compiler */ X#ifdef MSC X#define AFMT "%lx" X#define OFFTYPE long X#define INSEGMENT(n,s) (((OFFTYPE)(n) >> 16) == ((OFFTYPE)(s) >> 16)) X#define VCOMPARE(f,s,t) ((LVAL huge *)(f) + (s) < (LVAL huge *)(t)) X/* #define MSDOS -- MSC 5.0 defines this automatically */ X#endif X X/* for the Turbo C compiler */ X#ifdef _TURBOC_ X#define AFMT "%lx" X#define OFFTYPE long X#define INSEGMENT(n,s) (((OFFTYPE)(n) >> 16) == ((OFFTYPE)(s) >> 16)) X#define VCOMPARE(f,s,t) ((LVAL huge *)(f) + (s) < (LVAL huge *)(t)) X#define MSDOS X#endif X X/* size of each type of memory segment */ X#ifndef NSSIZE X#define NSSIZE 4000 /* number of nodes per node segment */ X#endif X#ifndef VSSIZE X#define VSSIZE 10000 /* number of LVAL's per vector segment */ X#endif X X/* default important definitions */ X#ifndef FORWARD X#define FORWARD X#endif X#ifndef LOCAL X#define LOCAL static X#endif X#ifndef AFMT X#define AFMT "%x" X#endif X#ifndef OFFTYPE X#define OFFTYPE int X#endif X#ifndef FIXTYPE X#define FIXTYPE long X#endif X#ifndef ITYPE X#define ITYPE long atol() X#endif X#ifndef ICNV X#define ICNV(n) atol(n) X#endif X#ifndef IFMT X#define IFMT "%ld" X#endif X#ifndef FLOTYPE X#define FLOTYPE double X#endif X#ifndef FFMT X#define FFMT "%.15g" X#endif X#ifndef SFIXMIN X#define SFIXMIN -1048576 X#define SFIXMAX 1048575 X#endif X#ifndef INSEGMENT X#define INSEGMENT(n,s) ((n) >= &(s)->ns_data[0] \ X && (n) < &(s)->ns_data[0] + (s)->ns_size) X#endif X#ifndef VCOMPARE X#define VCOMPARE(f,s,t) ((f) + (s) < (t)) X#endif X X/* useful definitions */ X#define TRUE 1 X#define FALSE 0 X#ifndef NIL X#define NIL (LVAL)0 X#endif X X/* program limits */ X#define STRMAX 100 /* maximum length of a string constant */ X#define HSIZE 199 /* symbol hash table size */ X#define SAMPLE 100 /* control character sample rate */ X X/* stack manipulation macros */ X#define check(n) { if (xlsp - (n) < xlstkbase) xlstkover(); } X#define cpush(v) { if (xlsp > xlstkbase) push(v); else xlstkover(); } X#define push(v) (*--xlsp = (v)) X#define pop() (*xlsp++) X#define top() (*xlsp) X#define settop(v) (*xlsp = (v)) X#define drop(n) (xlsp += (n)) X X/* argument list parsing macros */ X#define xlgetarg() (testarg(nextarg())) X#define xllastarg() {if (xlargc != 0) xltoomany();} X#define xlpoprest() {xlsp += xlargc;} X#define testarg(e) (moreargs() ? (e) : xltoofew()) X#define typearg(tp) (tp(*xlsp) ? nextarg() : xlbadtype(*xlsp)) X#define nextarg() (--xlargc, *xlsp++) X#define moreargs() (xlargc > 0) X X/* macros to get arguments of a particular type */ X#define xlgacons() (testarg(typearg(consp))) X#define xlgalist() (testarg(typearg(listp))) X#define xlgasymbol() (testarg(typearg(symbolp))) X#define xlgastring() (testarg(typearg(stringp))) X#define xlgaobject() (testarg(typearg(objectp))) X#define xlgafixnum() (testarg(typearg(fixp))) X#define xlganumber() (testarg(typearg(numberp))) X#define xlgachar() (testarg(typearg(charp))) X#define xlgavector() (testarg(typearg(vectorp))) X#define xlgaport() (testarg(typearg(portp))) X#define xlgaiport() (testarg(typearg(iportp))) X#define xlgaoport() (testarg(typearg(oportp))) X#define xlgaclosure() (testarg(typearg(closurep))) X#define xlgaenv() (testarg(typearg(envp))) X X/* node types */ X#define FREE 0 X#define CONS 1 X#define SYMBOL 2 X#define FIXNUM 3 X#define FLONUM 4 X#define STRING 5 X#define OBJECT 6 X#define PORT 7 X#define VECTOR 8 X#define CLOSURE 9 X#define METHOD 10 X#define CODE 11 X#define SUBR 12 X#define XSUBR 13 X#define CSUBR 14 X#define CONTINUATION 15 X#define CHAR 16 X#define PROMISE 17 X#define ENV 18 X X/* node flags */ X#define MARK 1 X#define LEFT 2 X X/* port flags */ X#define PF_INPUT 1 X#define PF_OUTPUT 2 X#define PF_BINARY 4 X X/* new node access macros */ X#define ntype(x) ((OFFTYPE)(x) & 1 ? FIXNUM : (x)->n_type) X X/* macro to determine if a non-nil value is a pointer */ X#define ispointer(x) (((OFFTYPE)(x) & 1) == 0) X X/* type predicates */ X#define atom(x) ((x) == NIL || ntype(x) != CONS) X#define null(x) ((x) == NIL) X#define listp(x) ((x) == NIL || ntype(x) == CONS) X#define numberp(x) ((x) && ntype(x) == FIXNUM || ntype(x) == FLONUM) X#define boundp(x) (getvalue(x) != s_unbound) X#define iportp(x) (portp(x) && (getpflags(x) & PF_INPUT) != 0) X#define oportp(x) (portp(x) && (getpflags(x) & PF_OUTPUT) != 0) X X/* basic type predicates */ X#define consp(x) ((x) && ntype(x) == CONS) X#define stringp(x) ((x) && ntype(x) == STRING) X#define symbolp(x) ((x) && ntype(x) == SYMBOL) X#define portp(x) ((x) && ntype(x) == PORT) X#define objectp(x) ((x) && ntype(x) == OBJECT) X#define fixp(x) ((x) && ntype(x) == FIXNUM) X#define floatp(x) ((x) && ntype(x) == FLONUM) X#define vectorp(x) ((x) && ntype(x) == VECTOR) X#define closurep(x) ((x) && ntype(x) == CLOSURE) X#define codep(x) ((x) && ntype(x) == CODE) X#define methodp(x) ((x) && ntype(x) == METHOD) X#define subrp(x) ((x) && ntype(x) == SUBR) X#define xsubrp(x) ((x) && ntype(x) == XSUBR) X#define charp(x) ((x) && ntype(x) == CHAR) X#define promisep(x) ((x) && ntype(x) == PROMISE) X#define envp(x) ((x) && ntype(x) == ENV) X#define booleanp(x) ((x) == NIL || ntype(x) == BOOLEAN) X X/* cons access macros */ X#define car(x) ((x)->n_car) X#define cdr(x) ((x)->n_cdr) X#define rplaca(x,y) ((x)->n_car = (y)) X#define rplacd(x,y) ((x)->n_cdr = (y)) X X/* symbol access macros */ X#define getvalue(x) ((x)->n_vdata[0]) X#define setvalue(x,v) ((x)->n_vdata[0] = (v)) X#define getpname(x) ((x)->n_vdata[1]) X#define setpname(x,v) ((x)->n_vdata[1] = (v)) X#define getplist(x) ((x)->n_vdata[2]) X#define setplist(x,v) ((x)->n_vdata[2] = (v)) X#define SYMSIZE 3 X X/* vector access macros */ X#define getsize(x) ((x)->n_vsize) X#define getelement(x,i) ((x)->n_vdata[i]) X#define setelement(x,i,v) ((x)->n_vdata[i] = (v)) X X/* object access macros */ X#define getclass(x) ((x)->n_vdata[1]) X#define setclass(x,v) ((x)->n_vdata[1] = (v)) X#define getivar(x,i) ((x)->n_vdata[i]) X#define setivar(x,i,v) ((x)->n_vdata[i] = (v)) X X/* promise access macros */ X#define getpproc(x) ((x)->n_car) X#define setpproc(x,v) ((x)->n_car = (v)) X#define getpvalue(x) ((x)->n_cdr) X#define setpvalue(x,v) ((x)->n_cdr = (v)) X X/* closure access macros */ X#define getcode(x) ((x)->n_car) X#define getenv(x) ((x)->n_cdr) X X/* code access macros */ X#define getbcode(x) ((x)->n_vdata[0]) X#define setbcode(x,v) ((x)->n_vdata[0] = (v)) X#define getcname(x) ((x)->n_vdata[1]) X#define setcname(x,v) ((x)->n_vdata[1] = (v)) X#define getvnames(x) ((x)->n_vdata[2]) X#define setvnames(x,v) ((x)->n_vdata[2] = (v)) X#define FIRSTLIT 3 X X/* fixnum/flonum/character access macros */ X#define getfixnum(x) ((OFFTYPE)(x) & 1 ? getsfixnum(x) : (x)->n_int) X#define getflonum(x) ((x)->n_flonum) X#define getchcode(x) ((x)->n_chcode) X X/* small fixnum access macros */ X#define cvsfixnum(x) ((LVAL)(((OFFTYPE)x << 1) | 1)) X#define getsfixnum(x) ((FIXTYPE)((OFFTYPE)(x) >> 1)) X X/* string access macros */ X#define getstring(x) ((unsigned char *)(x)->n_vdata) X#define getslength(x) ((x)->n_vsize) X X/* iport/oport access macros */ X#define getfile(x) ((x)->n_fp) X#define setfile(x,v) ((x)->n_fp = (v)) X#define getsavech(x) ((x)->n_savech) X#define setsavech(x,v) ((x)->n_savech = (v)) X#define getpflags(x) ((x)->n_pflags) X#define setpflags(x,v) ((x)->n_pflags = (v)) X X/* subr access macros */ X#define getsubr(x) ((x)->n_subr) X#define getoffset(x) ((x)->n_offset) X X/* list node */ X#define n_car n_info.n_xlist.xl_car X#define n_cdr n_info.n_xlist.xl_cdr X X/* integer node */ X#define n_int n_info.n_xint.xi_int X X/* flonum node */ X#define n_flonum n_info.n_xflonum.xf_flonum X X/* character node */ X#define n_chcode n_info.n_xchar.xc_chcode X X/* string node */ X#define n_str n_info.n_xstr.xst_str X#define n_strlen n_info.n_xstr.xst_length X X/* file pointer node */ X#define n_fp n_info.n_xfptr.xf_fp X#define n_savech n_info.n_xfptr.xf_savech X#define n_pflags n_info.n_xfptr.xf_pflags X X/* vector/object node */ X#define n_vsize n_info.n_xvect.xv_size X#define n_vdata n_info.n_xvect.xv_data X X/* subr node */ X#define n_subr n_info.n_xsubr.xs_subr X#define n_offset n_info.n_xsubr.xs_offset X X/* node structure */ Xtypedef struct node { X char n_type; /* type of node */ X char n_flags; /* flag bits */ X union ninfo { /* value */ X struct xlist { /* list node (cons) */ X struct node *xl_car; /* the car pointer */ X struct node *xl_cdr; /* the cdr pointer */ X } n_xlist; X struct xint { /* integer node */ X FIXTYPE xi_int; /* integer value */ X } n_xint; X struct xflonum { /* flonum node */ X FLOTYPE xf_flonum; /* flonum value */ X } n_xflonum; X struct xchar { /* character node */ X int xc_chcode; /* character code */ X } n_xchar; X struct xstr { /* string node */ X int xst_length; /* string length */ X unsigned char *xst_str; /* string pointer */ X } n_xstr; X struct xfptr { /* file pointer node */ X FILE *xf_fp; /* the file pointer */ X short xf_savech; /* lookahead character for input files */ X short xf_pflags; /* port flags */ X } n_xfptr; X struct xvect { /* vector node */ X int xv_size; /* vector size */ X struct node **xv_data; /* vector data */ X } n_xvect; X struct xsubr { /* subr/fsubr node */ X struct node *(*xs_subr)(); /* function pointer */ X int xs_offset; /* offset into funtab */ X } n_xsubr; X } n_info; X} NODE,*LVAL; X X/* memory allocator definitions */ X X/* macros to compute the size of a segment */ X#define nsegsize(n) (sizeof(NSEGMENT)+((n)-1)*sizeof(struct node)) X#define vsegsize(n) (sizeof(VSEGMENT)+((n)-1)*sizeof(LVAL)) X X/* macro to convert a byte size to a word size */ X#define btow_size(n) (((n) + sizeof(LVAL) - 1) / sizeof(LVAL)) X X/* node segment structure */ Xtypedef struct nsegment { X struct nsegment *ns_next; /* next node segment */ X unsigned int ns_size; /* number of nodes in this segment */ X struct node ns_data[1]; /* segment data */ X} NSEGMENT; X X/* vector segment structure */ Xtypedef struct vsegment { X struct vsegment *vs_next; /* next vector segment */ X LVAL *vs_free; /* next free location in this segment */ X LVAL *vs_top; /* top of segment (plus one) */ X LVAL vs_data[1]; /* segment data */ X} VSEGMENT; X X/* function definition structure */ Xtypedef struct { X char *fd_name; /* function name */ X LVAL (*fd_subr)(); /* function entry point */ X} FUNDEF; X X/* external variables */ Xextern LVAL *xlstkbase; /* base of value stack */ Xextern LVAL *xlstktop; /* top of value stack */ Xextern LVAL *xlsp; /* value stack pointer */ Xextern int xlargc; /* argument count for current call */ X X/* external routine declarations */ Xextern LVAL cons(); /* (cons x y) */ Xextern LVAL xlenter(); /* enter a symbol */ Xextern LVAL xlgetprop(); /* get the value of a property */ Xextern LVAL cvsymbol(); /* convert a string to a symbol */ Xextern LVAL cvstring(); /* convert a string */ Xextern LVAL cvfixnum(); /* convert a fixnum */ Xextern LVAL cvflonum(); /* convert a flonum */ Xextern LVAL cvchar(); /* convert a character */ Xextern LVAL cvclosure(); /* convert code and an env to a closure */ Xextern LVAL cvmethod(); /* convert code and an env to a method */ Xextern LVAL cvsubr(); /* convert a function into a subr */ Xextern LVAL cvport(); /* convert a file pointer to an input port */ Xextern LVAL cvpromise(); /* convert a procedure to a promise */ Xextern LVAL newstring(); /* create a new string */ Xextern LVAL newobject(); /* create a new object */ Xextern LVAL newvector(); /* create a new vector */ Xextern LVAL newcode(); /* create a new code object */ Xextern LVAL newcontinuation(); /* create a new continuation object */ Xextern LVAL newframe(); /* create a new environment frame */ Xextern LVAL newnode(); /* create a new node */ Xextern LVAL xltoofew(); /* report "too few arguments" */ Xextern LVAL xlbadtype(); /* report "wrong argument type" */ Xextern LVAL curinput(); /* get the current input port */ Xextern LVAL curoutput(); /* get the current output port */ END_OF_FILE if test 13100 -ne `wc -c <'Src/xscheme.h'`; then echo shar: \"'Src/xscheme.h'\" unpacked with wrong size! fi # end of 'Src/xscheme.h' fi if test -f 'Src/xsdmem.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'Src/xsdmem.c'\" else echo shar: Extracting \"'Src/xsdmem.c'\" $15137 characters$ sed "s/^X//" >'Src/xsdmem.c' <<'END_OF_FILE' X/* xsdmem.c - xscheme dynamic memory management routines */ X/* Copyright (c) 1988, by David Michael Betz X All Rights Reserved X Permission is granted for unrestricted non-commercial use */ X X#include "xscheme.h" X X/* virtual machine registers */ XLVAL xlfun=NIL; /* current function */ XLVAL xlenv=NIL; /* current environment */ XLVAL xlval=NIL; /* value of most recent instruction */ XLVAL *xlsp=NULL; /* value stack pointer */ X X/* stack limits */ XLVAL *xlstkbase=NULL; /* base of value stack */ XLVAL *xlstktop=NULL; /* top of value stack (actually, one beyond) */ X X/* variables shared with xsimage.c */ XFIXTYPE total=0; /* total number of bytes of memory in use */ XFIXTYPE gccalls=0; /* number of calls to the garbage collector */ X X/* node space */ XNSEGMENT *nsegments=NULL; /* list of node segments */ XNSEGMENT *nslast=NULL; /* last node segment */ Xint nscount=0; /* number of node segments */ XFIXTYPE nnodes=0; /* total number of nodes */ XFIXTYPE nfree=0; /* number of nodes in free list */ XLVAL fnodes=NIL; /* list of free nodes */ X X/* vector (and string) space */ XVSEGMENT *vsegments=NULL; /* list of vector segments */ XVSEGMENT *vscurrent=NULL; /* current vector segment */ Xint vscount=0; /* number of vector segments */ XLVAL *vfree=NULL; /* next free location in vector space */ XLVAL *vtop=NULL; /* top of vector space */ X X/* external variables */ Xextern LVAL s_unbound; /* *UNBOUND* symbol */ Xextern LVAL obarray; /* *OBARRAY* symbol */ Xextern LVAL default_object; /* default object */ Xextern LVAL eof_object; /* eof object */ Xextern LVAL true; /* truth value */ X X/* external routines */ Xextern unsigned char *calloc(); X X/* forward declarations */ XFORWARD LVAL allocnode(); XFORWARD LVAL allocvector(); X X/* cons - construct a new cons node */ XLVAL cons(x,y) X LVAL x,y; X{ X LVAL nnode; X X /* get a free node */ X if ((nnode = fnodes) == NIL) { X check(2); X push(x); X push(y); X findmemory(); X if ((nnode = fnodes) == NIL) X xlabort("insufficient node space"); X drop(2); X } X X /* unlink the node from the free list */ X fnodes = cdr(nnode); X --nfree; X X /* initialize the new node */ X nnode->n_type = CONS; X rplaca(nnode,x); X rplacd(nnode,y); X X /* return the new node */ X return (nnode); X} X X/* newframe - create a new environment frame */ XLVAL newframe(parent,size) X LVAL parent; int size; X{ X LVAL frame; X frame = cons(newvector(size),parent); X frame->n_type = ENV; X return (frame); X} X X/* cvstring - convert a string to a string node */ XLVAL cvstring(str) X unsigned char *str; X{ X LVAL val; X val = newstring(strlen(str)+1); X strcpy(getstring(val),str); X return (val); X} X X/* cvsymbol - convert a string to a symbol */ XLVAL cvsymbol(pname) X unsigned char *pname; X{ X LVAL val; X val = allocvector(SYMBOL,SYMSIZE); X cpush(val); X setvalue(val,s_unbound); X setpname(val,cvstring(pname)); X setplist(val,NIL); X return (pop()); X} X X/* cvfixnum - convert an integer to a fixnum node */ XLVAL cvfixnum(n) X FIXTYPE n; X{ X LVAL val; X if (n >= SFIXMIN && n <= SFIXMAX) X return (cvsfixnum(n)); X val = allocnode(FIXNUM); X val->n_int = n; X return (val); X} X X/* cvflonum - convert a floating point number to a flonum node */ XLVAL cvflonum(n) X FLOTYPE n; X{ X LVAL val; X val = allocnode(FLONUM); X val->n_flonum = n; X return (val); X} X X/* cvchar - convert an integer to a character node */ XLVAL cvchar(ch) X int ch; X{ X LVAL val; X val = allocnode(CHAR); X val->n_chcode = ch; X return (val); X} X X/* cvclosure - convert code and an environment to a closure */ XLVAL cvclosure(code,env) X LVAL code,env; X{ X LVAL val; X val = cons(code,env); X val->n_type = CLOSURE; X return (val); X} X X/* cvpromise - convert a procedure to a promise */ XLVAL cvpromise(code,env) X LVAL code,env; X{ X LVAL val; X val = cons(cvclosure(code,env),NIL); X val->n_type = PROMISE; X return (val); X} X X/* cvmethod - convert code and an environment to a method */ XLVAL cvmethod(code,class) X LVAL code,class; X{ X LVAL val; X val = cons(code,class); X val->n_type = METHOD; X return (val); X} X X/* cvsubr - convert a function to a subr/xsubr */ XLVAL cvsubr(type,fcn,offset) X int type; LVAL (*fcn)(); int offset; X{ X LVAL val; X val = allocnode(type); X val->n_subr = fcn; X val->n_offset = offset; X return (val); X} X X/* cvport - convert a file pointer to an port */ XLVAL cvport(fp,flags) X FILE *fp; int flags; X{ X LVAL val; X val = allocnode(PORT); X setfile(val,fp); X setsavech(val,'\0'); X setpflags(val,flags); X return (val); X} X X/* newvector - allocate and initialize a new vector */ XLVAL newvector(size) X int size; X{ X return (allocvector(VECTOR,size)); X} X X/* newstring - allocate and initialize a new string */ XLVAL newstring(size) X int size; X{ X LVAL val; X val = allocvector(STRING,btow_size(size)); X val->n_vsize = size; X return (val); X} X X/* newcode - create a new code object */ XLVAL newcode(nlits) X int nlits; X{ X return (allocvector(CODE,nlits)); X} X X/* newcontinuation - create a new continuation object */ XLVAL newcontinuation(size) X int size; X{ X return (allocvector(CONTINUATION,size)); X} X X/* newobject - allocate and initialize a new object */ XLVAL newobject(cls,size) X LVAL cls; int size; X{ X LVAL val; X val = allocvector(OBJECT,size+2); /* class, ivars */ X setclass(val,cls); X return (val); X} X X/* allocnode - allocate a new node */ XLOCAL LVAL allocnode(type) X int type; X{ X LVAL nnode; X X /* get a free node */ X if ((nnode = fnodes) == NIL) { X findmemory(); X if ((nnode = fnodes) == NIL) X xlabort("insufficient node space"); X } X X /* unlink the node from the free list */ X fnodes = cdr(nnode); X --nfree; X X /* initialize the new node */ X nnode->n_type = type; X rplacd(nnode,NIL); X X /* return the new node */ X return (nnode); X} X X/* findmemory - garbage collect, then add more node space if necessary */ XLOCAL findmemory() X{ X /* first try garbage collecting */ X gc(); X X /* expand memory only if less than one segment is free */ X if (nfree < (long)NSSIZE) X nexpand(1); X} X X/* nexpand - expand node space */ Xnexpand(n) X int n; X{ X NSEGMENT *newnsegment(),*newseg; X LVAL p; X int i; X X /* try to add n segments */ X while (--n >= 0) { X X /* allocate the new segment */ X if ((newseg = newnsegment(NSSIZE)) == NULL) X return; X X /* add each new node to the free list */ X p = &newseg->ns_data[0]; X for (i = NSSIZE; --i >= 0; ++p) { X p->n_type = FREE; X p->n_flags = 0; X rplacd(p,fnodes); X fnodes = p; X } X } X} X X/* allocvector - allocate and initialize a new vector node */ XLOCAL LVAL allocvector(type,size) X int type,size; X{ X register LVAL val,*p; X register int i; X X /* get a free node */ X if ((val = fnodes) == NIL) { X findmemory(); X if ((val = fnodes) == NIL) X xlabort("insufficient node space"); X } X X /* unlink the node from the free list */ X fnodes = cdr(fnodes); X --nfree; X X /* initialize the vector node */ X val->n_type = type; X val->n_vsize = size; X val->n_vdata = NULL; X cpush(val); X X /* add space for the backpointer */ X ++size; X X /* make sure there's enough space */ X if (!VCOMPARE(vfree,size,vtop)) { X findvmemory(size); X if (!VCOMPARE(vfree,size,vtop)) X xlabort("insufficient vector space"); X } X X /* allocate the next available block */ X p = vfree; X vfree += size; X X /* store the backpointer */ X *p++ = top(); X val->n_vdata = p; X X /* set all the elements to NIL */ X for (i = size; i > 1; --i) X *p++ = NIL; X X /* return the new vector */ X return (pop()); X} X X/* findvmemory - find vector memory */ Xfindvmemory(size) X int size; X{ X gc(); X makevmemory(size); X} X X/* makevmemory - make vector memory (used by 'xsimage.c') */ Xmakevmemory(size) X int size; X{ X VSEGMENT *vseg; X X /* look for a vector segment with enough space */ X for (vseg = vsegments; vseg != NULL; vseg = vseg->vs_next) X if (VCOMPARE(vseg->vs_free,size,vseg->vs_top)) { X if (vscurrent != NULL) X vscurrent->vs_free = vfree; X vfree = vseg->vs_free; X vtop = vseg->vs_top; X vscurrent = vseg; X return; X } X X /* allocate a new vector segment and make it current */ X vexpand(1); X} X X/* vexpand - expand vector space */ Xvexpand(n) X int n; X{ X VSEGMENT *newvsegment(),*vseg; X X /* try to add n segments */ X while (--n >= 0) { X if ((vseg = newvsegment(VSSIZE)) == NULL) X return; X if (vscurrent != NULL) X vscurrent->vs_free = vfree; X vfree = vseg->vs_free; X vtop = vseg->vs_top; X vscurrent = vseg; X } X} X X/* newnsegment - create a new node segment */ XNSEGMENT *newnsegment(n) X unsigned int n; X{ X NSEGMENT *newseg; X X /* allocate the new segment */ X if ((newseg = (NSEGMENT *)calloc(1,nsegsize(n))) == NULL) X return (NULL); X X /* initialize the new segment */ X newseg->ns_size = n; X newseg->ns_next = NULL; X if (nsegments) X nslast->ns_next = newseg; X else X nsegments = newseg; X nslast = newseg; X X /* update the statistics */ X total += (long)nsegsize(n); X nnodes += (long)n; X nfree += (long)n; X ++nscount; X X /* return the new segment */ X return (newseg); X} X X/* newvsegment - create a new vector segment */ XVSEGMENT *newvsegment(n) X unsigned int n; X{ X VSEGMENT *newseg; X X /* allocate the new segment */ X if ((newseg = (VSEGMENT *)calloc(1,vsegsize(n))) == NULL) X return (NULL); X X /* initialize the new segment */ X newseg->vs_free = &newseg->vs_data[0]; X newseg->vs_top = newseg->vs_free + n; X newseg->vs_next = vsegments; X vsegments = newseg; X X /* update the statistics */ X total += (long)vsegsize(n); X ++vscount; X X /* return the new segment */ X return (newseg); X} X X/* gc - garbage collect */ Xgc() X{ X register LVAL *p,tmp; X int compact(); X X /* mark the obarray and the current environment */ X if (obarray && ispointer(obarray)) X mark(obarray); X if (xlfun && ispointer(xlfun)) X mark(xlfun); X if (xlenv && ispointer(xlenv)) X mark(xlenv); X if (xlval && ispointer(xlval)) X mark(xlval); X if (default_object && ispointer(default_object)) X mark(default_object); X if (eof_object && ispointer(eof_object)) X mark(eof_object); X if (true && ispointer(true)) X mark(true); X X /* mark the stack */ X for (p = xlsp; p < xlstktop; ++p) X if ((tmp = *p) && ispointer(tmp)) X mark(tmp); X X /* compact vector space */ X gc_protect(compact); X X /* sweep memory collecting all unmarked nodes */ X sweep(); X X /* count the gc call */ X ++gccalls; X} X X/* mark - mark all accessible nodes */ XLOCAL mark(ptr) X LVAL ptr; X{ X register LVAL this,prev,tmp; X X /* initialize */ X prev = NIL; X this = ptr; X X /* mark this node */ X for (;;) { X X /* descend as far as we can */ X while (!(this->n_flags & MARK)) X X /* mark this node and trace its children */ X switch (this->n_type) { X case CONS: /* mark cons-like nodes */ X case CLOSURE: X case METHOD: X case PROMISE: X case ENV: X this->n_flags |= MARK; X if ((tmp = car(this)) && ispointer(tmp)) { X this->n_flags |= LEFT; X rplaca(this,prev); X prev = this; X this = tmp; X } X else if ((tmp = cdr(this)) && ispointer(tmp)) { X rplacd(this,prev); X prev = this; X this = tmp; X } X break; X case SYMBOL: /* mark vector-like nodes */ X case OBJECT: X case VECTOR: X case CODE: X case CONTINUATION: X this->n_flags |= MARK; X markvector(this); X break; X default: /* mark all other types of nodes */ X this->n_flags |= MARK; X break; X } X X /* backup to a point where we can continue descending */ X for (;;) X X /* make sure there is a previous node */ X if (prev) { X if (prev->n_flags & LEFT) { /* came from left side */ X prev->n_flags &= ~LEFT; X tmp = car(prev); X rplaca(prev,this); X if ((this = cdr(prev)) && ispointer(this)) { X rplacd(prev,tmp); X break; X } X } X else { /* came from right side */ X tmp = cdr(prev); X rplacd(prev,this); X } X this = prev; /* step back up the branch */ X prev = tmp; X } X X /* no previous node, must be done */ X else X return; X } X} X X/* markvector - mark a vector-like node */ XLOCAL markvector(vect) X LVAL vect; X{ X register LVAL tmp,*p; X register int n; X if (p = vect->n_vdata) { X n = getsize(vect); X while (--n >= 0) X if ((tmp = *p++) != NULL && ispointer(tmp)) X mark(tmp); X } X} X X/* compact - compact vector space */ XLOCAL compact() X{ X VSEGMENT *vseg; X X /* store the current segment information */ X if (vscurrent) X vscurrent->vs_free = vfree; X X /* compact each vector segment */ X for (vseg = vsegments; vseg != NULL; vseg = vseg->vs_next) X compact_vector(vseg); X X /* make the first vector segment current */ X if (vscurrent = vsegments) { X vfree = vscurrent->vs_free; X vtop = vscurrent->vs_top; X } X} X X/* compact_vector - compact a vector segment */ XLOCAL compact_vector(vseg) X VSEGMENT *vseg; X{ X register LVAL *vdata,*vnext,*vfree,vector; X register int vsize; X X vdata = vnext = &vseg->vs_data[0]; X vfree = vseg->vs_free; X while (vdata < vfree) { X vector = *vdata; X if (vector->n_type == STRING) X vsize = btow_size(vector->n_vsize) + 1; X else X vsize = vector->n_vsize + 1; X if (vector->n_flags & MARK) { X if (vdata == vnext) { X vdata += vsize; X vnext += vsize; X } X else { X vector->n_vdata = vnext + 1; X while (vsize > 0) { X *vnext++ = *vdata++; X --vsize; X } X } X } X else X vdata += vsize; X } X vseg->vs_free = vnext; X} X X/* sweep - sweep all unmarked nodes and add them to the free list */ XLOCAL sweep() X{ X NSEGMENT *nseg; X X /* empty the free list */ X fnodes = NIL; X nfree = 0L; X X /* sweep each node segment */ X for (nseg = nsegments; nseg != NULL; nseg = nseg->ns_next) X sweep_segment(nseg); X} X X/* sweep_segment - sweep a node segment */ XLOCAL sweep_segment(nseg) X NSEGMENT *nseg; X{ X register FIXTYPE n; X register LVAL p; X X /* add all unmarked nodes */ X for (p = &nseg->ns_data[0], n = nseg->ns_size; --n >= 0L; ++p) X if (!(p->n_flags & MARK)) { X switch (p->n_type) { X case PORT: X if (getfile(p)) X osclose(getfile(p)); X break; X } X p->n_type = FREE; X rplacd(p,fnodes); X fnodes = p; X ++nfree; X } X else X p->n_flags &= ~MARK; X} X X/* xlminit - initialize the dynamic memory module */ Xxlminit(ssize) X unsigned int ssize; X{ X unsigned int n; X X /* initialize our internal variables */ X gccalls = 0; X total = 0L; X X /* initialize node space */ X nsegments = nslast = NULL; X nscount = 0; X nnodes = nfree = 0L; X fnodes = NIL; X X /* initialize vector space */ X vsegments = vscurrent = NULL; X vscount = 0; X vfree = vtop = NULL; X X /* allocate the value stack */ X n = ssize * sizeof(LVAL); X if ((xlstkbase = (LVAL *)calloc(1,n)) == NULL) X xlfatal("insufficient memory"); X total += (long)n; X X /* initialize structures that are marked by the collector */ X obarray = default_object = eof_object = true = NIL; X xlfun = xlenv = xlval = NIL; X X /* initialize the stack */ X xlsp = xlstktop = xlstkbase + ssize; X} END_OF_FILE if test 15137 -ne `wc -c <'Src/xsdmem.c'`; then echo shar: \"'Src/xsdmem.c'\" unpacked with wrong size! fi # end of 'Src/xsdmem.c' fi if test -f 'Src/xsftab.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'Src/xsftab.c'\" else echo shar: Extracting \"'Src/xsftab.c'\" $14063 characters$ sed "s/^X//" >'Src/xsftab.c' <<'END_OF_FILE' X/* xsftab.c - built-in function table */ X/* Copyright (c) 1988, by David Michael Betz X All Rights Reserved X Permission is granted for unrestricted non-commercial use */ X X#include "xscheme.h" X X/* external variables */ Xextern LVAL s_stdin,s_stdout; X X/* external functions */ Xextern LVAL X xapply(),xcallcc(),xmap(),xmap1(),xforeach(),xforeach1(), X xforce(),xforce1(),xcallwi(),xcallwo(),xwithfile1(), X xload(),xloadnoisily(),xload1(), X xsendsuper(),clnew(),clisnew(),clanswer(), X obisnew(),obclass(),obshow(), X xcons(),xcar(),xcdr(), X xcaar(),xcadr(),xcdar(),xcddr(), X xcaaar(),xcaadr(),xcadar(),xcaddr(), X xcdaar(),xcdadr(),xcddar(),xcdddr(), X xcaaaar(),xcaaadr(),xcaadar(),xcaaddr(), X xcadaar(),xcadadr(),xcaddar(),xcadddr(), X xcdaaar(),xcdaadr(),xcdadar(),xcdaddr(), X xcddaar(),xcddadr(),xcdddar(),xcddddr(), X xsetcar(),xsetcdr(),xlist(), X xappend(),xreverse(),xlastpair(),xlength(),xlistref(),xlisttail(), X xmember(),xmemv(),xmemq(),xassoc(),xassv(),xassq(), X xsymvalue(),xsetsymvalue(),xsymplist(),xsetsymplist(),xgensym(), X xboundp(),xget(),xput(), X xtheenvironment(),xprocenvironment(),xenvp(),xenvbindings(),xenvparent(), X xvector(),xmakevector(),xvlength(),xvref(),xvset(), X xvectlist(),xlistvect(), X xmakearray(),xaref(),xaset(), X xsymstr(),xstrsym(), X xnull(),xatom(),xlistp(),xnumberp(),xbooleanp(), X xpairp(),xsymbolp(),xintegerp(),xrealp(),xcharp(),xstringp(),xvectorp(), X xprocedurep(),xobjectp(),xdefaultobjectp(), X xinputportp(),xoutputportp(),xportp(), X xeq(),xeqv(),xequal(), X xzerop(),xpositivep(),xnegativep(),xoddp(),xevenp(), X xexactp(),xinexactp(), X xadd1(),xsub1(),xabs(),xgcd(),xrandom(), X xadd(),xsub(),xmul(),xdiv(),xquo(),xrem(),xmin(),xmax(), X xsin(),xcos(),xtan(),xasin(),xacos(),xatan(), X xxexp(),xsqrt(),xexpt(),xxlog(),xtruncate(),xfloor(),xceiling(),xround(), X xlogand(),xlogior(),xlogxor(),xlognot(), X xlss(),xleq(),xeql(),xgeq(),xgtr(), X xstrlen(),xstrnullp(),xstrappend(),xstrref(),xsubstring(), X xstrlist(),xliststring(), X xstrlss(),xstrleq(),xstreql(),xstrgeq(),xstrgtr(), X xstrilss(),xstrileq(),xstrieql(),xstrigeq(),xstrigtr(), X xcharint(),xintchar(), X xchrlss(),xchrleq(),xchreql(),xchrgeq(),xchrgtr(), X xchrilss(),xchrileq(),xchrieql(),xchrigeq(),xchrigtr(), X xread(),xrdchar(),xrdbyte(),xrdshort(),xrdlong(),xeofobjectp(), X xwrite(),xwrchar(),xwrbyte(),xwrshort(),xwrlong(), X xdisplay(),xnewline(),xprint(),xprbreadth(),xprdepth(), X xopeni(),xopeno(),xopena(),xopenu(),xclosei(),xcloseo(),xclose(), X xgetfposition(),xsetfposition(),xcurinput(),xcuroutput(), X xtranson(),xtransoff(),xgetarg(),xexit(),xcompile(),xdecompile(),xgc(), X xsave(),xrestore(),xtraceon(),xtraceoff(),xreset(),xerror(), X xicar(),xicdr(),xisetcar(),xisetcdr(),xivlength(),xivref(),xivset(); X#ifdef MACINTOSH Xextern LVAL xhidepen(),xshowpen(),xgetpen(),xpensize(),xpenmode(); Xextern LVAL xpenpat(),xpennormal(),xmoveto(),xmove(),xlineto(),xline(); Xextern LVAL xshowgraphics(),xhidegraphics(),xcleargraphics(); X#endif X#ifdef MSDOS Xextern LVAL xint86(),xinbyte(),xoutbyte(),xsystem(),xgetkey(); X#endif X#ifdef UNIX Xextern LVAL xsystem(); X#endif X#ifdef AZTEC_AMIGA Xextern LVAL xsystem(); X#endif X Xint xsubrcnt = 12; /* number of XSUBR functions */ Xint csubrcnt = 17; /* number of CSUBR functions + xsubrcnt */ X X/* built-in functions */ XFUNDEF funtab[] = { X X /* functions that call eval or apply (# must match xsubrcnt) */ X{ "APPLY", xapply }, X{ "CALL-WITH-CURRENT-CONTINUATION", xcallcc }, X{ "CALL/CC", xcallcc }, X{ "MAP", xmap }, X{ "FOR-EACH", xforeach }, X{ "CALL-WITH-INPUT-FILE", xcallwi }, X{ "CALL-WITH-OUTPUT-FILE", xcallwo }, X{ "LOAD", xload }, X{ "LOAD-NOISILY", xloadnoisily }, X{ "SEND-SUPER", xsendsuper }, X{ "%CLASS-NEW", clnew }, X{ "FORCE", xforce }, X X /* continuations for xsubrs (# must match csubrcnt) */ X{ "%MAP1", xmap1 }, X{ "%FOR-EACH1", xforeach1 }, X{ "%WITH-FILE1", xwithfile1 }, X{ "%LOAD1", xload1 }, X{ "%FORCE1", xforce1 }, X X /* methods */ X{ "%CLASS-ISNEW", clisnew }, X{ "%CLASS-ANSWER", clanswer }, X{ "%OBJECT-ISNEW", obisnew }, X{ "%OBJECT-CLASS", obclass }, X{ "%OBJECT-SHOW", obshow }, X X /* list functions */ X{ "CONS", xcons }, X{ "CAR", xcar }, X{ "CDR", xcdr }, X{ "CAAR", xcaar }, X{ "CADR", xcadr }, X{ "CDAR", xcdar }, X{ "CDDR", xcddr }, X{ "CAAAR", xcaaar }, X{ "CAADR", xcaadr }, X{ "CADAR", xcadar }, X{ "CADDR", xcaddr }, X{ "CDAAR", xcdaar }, X{ "CDADR", xcdadr }, X{ "CDDAR", xcddar }, X{ "CDDDR", xcdddr }, X{ "CAAAAR", xcaaaar }, X{ "CAAADR", xcaaadr }, X{ "CAADAR", xcaadar }, X{ "CAADDR", xcaaddr }, X{ "CADAAR", xcadaar }, X{ "CADADR", xcadadr }, X{ "CADDAR", xcaddar }, X{ "CADDDR", xcadddr }, X{ "CDAAAR", xcdaaar }, X{ "CDAADR", xcdaadr }, X{ "CDADAR", xcdadar }, X{ "CDADDR", xcdaddr }, X{ "CDDAAR", xcddaar }, X{ "CDDADR", xcddadr }, X{ "CDDDAR", xcdddar }, X{ "CDDDDR", xcddddr }, X{ "LIST", xlist }, X{ "APPEND", xappend }, X{ "REVERSE", xreverse }, X{ "LAST-PAIR", xlastpair }, X{ "LENGTH", xlength }, X{ "MEMBER", xmember }, X{ "MEMV", xmemv }, X{ "MEMQ", xmemq }, X{ "ASSOC", xassoc }, X{ "ASSV", xassv }, X{ "ASSQ", xassq }, X{ "LIST-REF", xlistref }, X{ "LIST-TAIL", xlisttail }, X X /* destructive list functions */ X{ "SET-CAR!", xsetcar }, X{ "SET-CDR!", xsetcdr }, X X X /* symbol functions */ X{ "BOUND?", xboundp }, X{ "SYMBOL-VALUE", xsymvalue }, X{ "SET-SYMBOL-VALUE!", xsetsymvalue }, X{ "SYMBOL-PLIST", xsymplist }, X{ "SET-SYMBOL-PLIST!", xsetsymplist }, X{ "GENSYM", xgensym }, X{ "GET", xget }, X{ "PUT", xput }, X X /* environment functions */ X{ "THE-ENVIRONMENT", xtheenvironment }, X{ "PROCEDURE-ENVIRONMENT", xprocenvironment}, X{ "ENVIRONMENT?", xenvp }, X{ "ENVIRONMENT-BINDINGS", xenvbindings }, X{ "ENVIRONMENT-PARENT", xenvparent }, X X /* vector functions */ X{ "VECTOR", xvector }, X{ "MAKE-VECTOR", xmakevector }, X{ "VECTOR-LENGTH", xvlength }, X{ "VECTOR-REF", xvref }, X{ "VECTOR-SET!", xvset }, X X /* array functions */ X{ "MAKE-ARRAY", xmakearray }, X{ "ARRAY-REF", xaref }, X{ "ARRAY-SET!", xaset }, X X /* conversion functions */ X{ "SYMBOL->STRING", xsymstr }, X{ "STRING->SYMBOL", xstrsym }, X{ "VECTOR->LIST", xvectlist }, X{ "LIST->VECTOR", xlistvect }, X{ "STRING->LIST", xstrlist }, X{ "LIST->STRING", xliststring }, X{ "CHAR->INTEGER", xcharint }, X{ "INTEGER->CHAR", xintchar }, X X /* predicate functions */ X{ "NULL?", xnull }, X{ "ATOM?", xatom }, X{ "LIST?", xlistp }, X{ "NUMBER?", xnumberp }, X{ "BOOLEAN?", xbooleanp }, X{ "PAIR?", xpairp }, X{ "SYMBOL?", xsymbolp }, X{ "COMPLEX?", xrealp }, /*(1)*/ X{ "REAL?", xrealp }, X{ "RATIONAL?", xintegerp }, /*(1)*/ X{ "INTEGER?", xintegerp }, X{ "CHAR?", xcharp }, X{ "STRING?", xstringp }, X{ "VECTOR?", xvectorp }, X{ "PROCEDURE?", xprocedurep }, X{ "PORT?", xportp }, X{ "INPUT-PORT?", xinputportp }, X{ "OUTPUT-PORT?", xoutputportp }, X{ "OBJECT?", xobjectp }, X{ "EOF-OBJECT?", xeofobjectp }, X{ "DEFAULT-OBJECT?", xdefaultobjectp }, X{ "EQ?", xeq }, X{ "EQV?", xeqv }, X{ "EQUAL?", xequal }, X X /* arithmetic functions */ X{ "ZERO?", xzerop }, X{ "POSITIVE?", xpositivep }, X{ "NEGATIVE?", xnegativep }, X{ "ODD?", xoddp }, X{ "EVEN?", xevenp }, X{ "EXACT?", xexactp }, X{ "INEXACT?", xinexactp }, X{ "TRUNCATE", xtruncate }, X{ "FLOOR", xfloor }, X{ "CEILING", xceiling }, X{ "ROUND", xround }, X{ "1+", xadd1 }, X{ "-1+", xsub1 }, X{ "ABS", xabs }, X{ "GCD", xgcd }, X{ "RANDOM", xrandom }, X{ "+", xadd }, X{ "-", xsub }, X{ "*", xmul }, X{ "/", xdiv }, X{ "QUOTIENT", xquo }, X{ "REMAINDER", xrem }, X{ "MIN", xmin }, X{ "MAX", xmax }, X{ "SIN", xsin }, X{ "COS", xcos }, X{ "TAN", xtan }, X{ "ASIN", xasin }, X{ "ACOS", xacos }, X{ "ATAN", xatan }, X{ "EXP", xxexp }, X{ "SQRT", xsqrt }, X{ "EXPT", xexpt }, X{ "LOG", xxlog }, X X /* bitwise logical functions */ X{ "LOGAND", xlogand }, X{ "LOGIOR", xlogior }, X{ "LOGXOR", xlogxor }, X{ "LOGNOT", xlognot }, X X /* numeric comparison functions */ X{ "<", xlss }, X{ "<=", xleq }, X{ "=", xeql }, X{ ">=", xgeq }, X{ ">", xgtr }, X X /* string functions */ X{ "STRING-LENGTH", xstrlen }, X{ "STRING-NULL?", xstrnullp }, X{ "STRING-APPEND", xstrappend }, X{ "STRING-REF", xstrref }, X{ "SUBSTRING", xsubstring }, X{ "STRING<?", xstrlss }, X{ "STRING<=?", xstrleq }, X{ "STRING=?", xstreql }, X{ "STRING>=?", xstrgeq }, X{ "STRING>?", xstrgtr }, X{ "STRING-CI<?", xstrilss }, X{ "STRING-CI<=?", xstrileq }, X{ "STRING-CI=?", xstrieql }, X{ "STRING-CI>=?", xstrigeq }, X{ "STRING-CI>?", xstrigtr }, X X /* character functions */ X{ "CHAR<?", xchrlss }, X{ "CHAR<=?", xchrleq }, X{ "CHAR=?", xchreql }, X{ "CHAR>=?", xchrgeq }, X{ "CHAR>?", xchrgtr }, X{ "CHAR-CI<?", xchrilss }, X{ "CHAR-CI<=?", xchrileq }, X{ "CHAR-CI=?", xchrieql }, X{ "CHAR-CI>=?", xchrigeq }, X{ "CHAR-CI>?", xchrigtr }, X X /* I/O functions */ X{ "READ", xread }, X{ "READ-CHAR", xrdchar }, X{ "READ-BYTE", xrdbyte }, X{ "READ-SHORT", xrdshort }, X{ "READ-LONG", xrdlong }, X{ "WRITE", xwrite }, X{ "WRITE-CHAR", xwrchar }, X{ "WRITE-BYTE", xwrbyte }, X{ "WRITE-SHORT", xwrshort }, X{ "WRITE-LONG", xwrlong }, X{ "DISPLAY", xdisplay }, X{ "PRINT", xprint }, X{ "NEWLINE", xnewline }, X X /* print control functions */ X{ "PRINT-BREADTH", xprbreadth }, X{ "PRINT-DEPTH", xprdepth }, X X /* file I/O functions */ X{ "OPEN-INPUT-FILE", xopeni }, X{ "OPEN-OUTPUT-FILE", xopeno }, X{ "OPEN-APPEND-FILE", xopena }, X{ "OPEN-UPDATE-FILE", xopenu }, X{ "CLOSE-PORT", xclose }, X{ "CLOSE-INPUT-PORT", xclosei }, X{ "CLOSE-OUTPUT-PORT", xcloseo }, X{ "GET-FILE-POSITION", xgetfposition }, X{ "SET-FILE-POSITION!", xsetfposition }, X{ "CURRENT-INPUT-PORT", xcurinput }, X{ "CURRENT-OUTPUT-PORT", xcuroutput }, X X /* utility functions */ X{ "TRANSCRIPT-ON", xtranson }, X{ "TRANSCRIPT-OFF", xtransoff }, X{ "GETARG", xgetarg }, X{ "EXIT", xexit }, X{ "COMPILE", xcompile }, X{ "DECOMPILE", xdecompile }, X{ "GC", xgc }, X{ "SAVE", xsave }, X{ "RESTORE", xrestore }, X{ "RESET", xreset }, X{ "ERROR", xerror }, X X /* debugging functions */ X{ "TRACE-ON", xtraceon }, X{ "TRACE-OFF", xtraceoff }, X X /* internal functions */ X{ "%CAR", xicar }, X{ "%CDR", xicdr }, X{ "%SET-CAR!", xisetcar }, X{ "%SET-CDR!", xisetcdr }, X{ "%VECTOR-LENGTH", xivlength }, X{ "%VECTOR-REF", xivref }, X{ "%VECTOR-SET!", xivset }, X X#ifdef MACINTOSH X{ "HIDEPEN", xhidepen }, X{ "SHOWPEN", xshowpen }, X{ "GETPEN", xgetpen }, X{ "PENSIZE", xpensize }, X{ "PENMODE", xpenmode }, X{ "PENPAT", xpenpat }, X{ "PENNORMAL", xpennormal }, X{ "MOVETO", xmoveto }, X{ "MOVE", xmove }, X{ "LINETO", xlineto }, X{ "LINE", xline }, X{ "SHOW-GRAPHICS", xshowgraphics }, X{ "HIDE-GRAPHICS", xhidegraphics }, X{ "CLEAR-GRAPHICS", xcleargraphics }, X#endif X X#ifdef MSDOS X{ "INT86", xint86 }, X{ "INBYTE", xinbyte }, X{ "OUTBYTE", xoutbyte }, X{ "SYSTEM", xsystem }, X{ "GET-KEY", xgetkey }, X#endif X X#ifdef UNIX X{ "SYSTEM", xsystem }, X#endif X X#ifdef AZTEC_AMIGA X{ "SYSTEM", xsystem }, X#endif X X{0,0} /* end of table marker */ X X}; X X/* Notes: X X (1) This version only supports integers and reals. X X*/ X X/* curinput - get the current input port */ XLVAL curinput() X{ X return (getvalue(s_stdin)); X} X X/* curoutput - get the current output port */ XLVAL curoutput() X{ X return (getvalue(s_stdout)); X} X X/* eq - internal 'eq?' function */ Xint eq(arg1,arg2) X LVAL arg1,arg2; X{ X return (arg1 == arg2); X} X X/* eqv - internal 'eqv?' function */ Xint eqv(arg1,arg2) X LVAL arg1,arg2; X{ X /* try the eq test first */ X if (arg1 == arg2) X return (TRUE); X X /* compare fixnums, flonums and characters */ X if (!null(arg1)) { X switch (ntype(arg1)) { X case FIXNUM: X return (fixp(arg2) X && getfixnum(arg1) == getfixnum(arg2)); X case FLONUM: X return (floatp(arg2) X && getflonum(arg1) == getflonum(arg2)); X case CHAR: X return (charp(arg2) X && getchcode(arg1) == getchcode(arg2)); X } X } X return (FALSE); X} X X/* equal - internal 'equal?' function */ Xint equal(arg1,arg2) X LVAL arg1,arg2; X{ X /* try the eq test first */ X if (arg1 == arg2) X return (TRUE); X X /* compare fixnums, flonums, characters, strings, vectors and conses */ X if (!null(arg1)) { X switch (ntype(arg1)) { X case FIXNUM: X return (fixp(arg2) X && getfixnum(arg1) == getfixnum(arg2)); X case FLONUM: X return (floatp(arg2) X && getflonum(arg1) == getflonum(arg2)); X case CHAR: X return (charp(arg2) X && getchcode(arg1) == getchcode(arg2)); X case STRING: X return (stringp(arg2) X && strcmp(getstring(arg1),getstring(arg2)) == 0); X case VECTOR: X return (vectorp(arg2) X && vectorequal(arg1,arg2)); X case CONS: X return (consp(arg2) X && equal(car(arg1),car(arg2)) X && equal(cdr(arg1),cdr(arg2))); X } X } X return (FALSE); X} X X/* vectorequal - compare two vectors */ Xint vectorequal(v1,v2) X LVAL v1,v2; X{ X int len,i; X X /* compare the vector lengths */ X if ((len = getsize(v1)) != getsize(v2)) X return (FALSE); X X /* compare the vector elements */ X for (i = 0; i < len; ++i) X if (!equal(getelement(v1,i),getelement(v2,i))) X return (FALSE); X return (TRUE); X} X X/* xltoofew - too few arguments to this function */ XLVAL xltoofew() X{ X xlfail("too few arguments"); X} X X/* xltoomany - too many arguments to this function */ Xxltoomany() X{ X xlfail("too many arguments"); X} X X/* xlbadtype - incorrect argument type */ XLVAL xlbadtype(val) X LVAL val; X{ X xlerror("incorrect type",val); X} END_OF_FILE if test 14063 -ne `wc -c <'Src/xsftab.c'`; then echo shar: \"'Src/xsftab.c'\" unpacked with wrong size! fi # end of 'Src/xsftab.c' fi if test -f 'Src/xsmath.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'Src/xsmath.c'\" else echo shar: Extracting \"'Src/xsmath.c'\" $13437 characters$ sed "s/^X//" >'Src/xsmath.c' <<'END_OF_FILE' X/* xsmath.c - xscheme built-in arithmetic functions */ X/* Copyright (c) 1988, by David Michael Betz X All Rights Reserved X Permission is granted for unrestricted non-commercial use */ X X#include "xscheme.h" X#include <math.h> X X/* external variables */ Xextern LVAL true; X X/* forward declarations */ XFORWARD LVAL unary(); XFORWARD LVAL binary(); XFORWARD LVAL predicate(); XFORWARD LVAL compare(); XFORWARD FLOTYPE toflotype(); X X/* xexactp - built-in function 'exact?' */ X/**** THIS IS REALLY JUST A STUB FOR NOW ****/ XLVAL xexactp() X{ X LVAL arg; X arg = xlganumber(); X xllastarg(); X return (NIL); X} X X/* xinexactp - built-in function 'inexact?' */ X/**** THIS IS REALLY JUST A STUB FOR NOW ****/ XLVAL xinexactp() X{ X LVAL arg; X arg = xlganumber(); X xllastarg(); X return (true); X} X X/* xatan - built-in function 'atan' */ XLVAL xatan() X{ X LVAL arg,arg2; X FLOTYPE val; X X /* get the first argument */ X arg = xlganumber(); X X /* handle two argument (atan y x) */ X if (moreargs()) { X arg2 = xlganumber(); X xllastarg(); X val = atan2(toflotype(arg),toflotype(arg2)); X } X X /* handle one argument (atan x) */ X else X val = atan(toflotype(arg)); X X /* return the resulting flonum */ X return (cvflonum(val)); X} X X/* xfloor - built-in function 'floor' */ XLVAL xfloor() X{ X LVAL arg; X X /* get the argument */ X arg = xlgetarg(); X xllastarg(); X X /* check its type */ X if (fixp(arg)) X return (arg); X else if (floatp(arg)) X return (cvfixnum((FIXTYPE)floor(getflonum(arg)))); X else X xlbadtype(arg); X} X X/* xceiling - built-in function 'ceiling' */ XLVAL xceiling() X{ X LVAL arg; X X /* get the argument */ X arg = xlgetarg(); X xllastarg(); X X /* check its type */ X if (fixp(arg)) X return (arg); X else if (floatp(arg)) X return (cvfixnum((FIXTYPE)ceil(getflonum(arg)))); X else X xlbadtype(arg); X} X X/* xround - built-in function 'round' */ XLVAL xround() X{ X FLOTYPE x,y,z; X LVAL arg; X X /* get the argument */ X arg = xlgetarg(); X xllastarg(); X X /* check its type */ X if (fixp(arg)) X return (arg); X else if (floatp(arg)) { X x = getflonum(arg); X y = floor(x); X z = x - y; X if (z == 0.5) { X if (((FIXTYPE)y & 1) == 1) X y += 1.0; X return (cvfixnum((FIXTYPE)y)); X } X else if (z < 0.5) X return (cvfixnum((FIXTYPE)y)); X else X return (cvfixnum((FIXTYPE)(y + 1.0))); X } X else X xlbadtype(arg); X} X X/* xtruncate - built-in function 'truncate' */ XLVAL xtruncate() X{ X LVAL arg; X X /* get the argument */ X arg = xlgetarg(); X xllastarg(); X X /* check its type */ X if (fixp(arg)) X return (arg); X else if (floatp(arg)) X return (cvfixnum((FIXTYPE)(getflonum(arg)))); X else X xlbadtype(arg); X} X X/* binary functions */ XLVAL xadd() /* + */ X{ X if (!moreargs()) X return (cvfixnum((FIXTYPE)0)); X return (binary('+')); X} XLVAL xmul() /* * */ X{ X if (!moreargs()) X return (cvfixnum((FIXTYPE)1)); X return (binary('*')); X} XLVAL xsub() { return (binary('-')); } /* - */ XLVAL xdiv() { return (binary('/')); } /* / */ XLVAL xquo() { return (binary('Q')); } /* quotient */ XLVAL xrem() { return (binary('R')); } /* remainder */ XLVAL xmin() { return (binary('m')); } /* min */ XLVAL xmax() { return (binary('M')); } /* max */ XLVAL xexpt() { return (binary('E')); } /* expt */ XLVAL xlogand() { return (binary('&')); } /* logand */ XLVAL xlogior() { return (binary('|')); } /* logior */ XLVAL xlogxor() { return (binary('^')); } /* logxor */ X X/* binary - handle binary operations */ XLOCAL LVAL binary(fcn) X int fcn; X{ X FIXTYPE ival,iarg; X FLOTYPE fval,farg; X LVAL arg; X int mode; X X /* get the first argument */ X arg = xlgetarg(); X X /* set the type of the first argument */ X if (fixp(arg)) { X ival = getfixnum(arg); X mode = 'I'; X } X else if (floatp(arg)) { X fval = getflonum(arg); X mode = 'F'; X } X else X xlbadtype(arg); X X /* treat a single argument as a special case */ X if (!moreargs()) { X switch (fcn) { X case '-': X switch (mode) { X case 'I': X ival = -ival; X break; X case 'F': X fval = -fval; X break; X } X break; X case '/': X switch (mode) { X case 'I': X checkizero(ival); X if (ival != 1) { X fval = 1.0 / (FLOTYPE)ival; X mode = 'F'; X } X break; X case 'F': X checkfzero(fval); X fval = 1.0 / fval; X break; X } X } X } X X /* handle each remaining argument */ X while (moreargs()) { X X /* get the next argument */ X arg = xlgetarg(); X X /* check its type */ X if (fixp(arg)) { X switch (mode) { X case 'I': X iarg = getfixnum(arg); X break; X case 'F': X farg = (FLOTYPE)getfixnum(arg); X break; X } X } X else if (floatp(arg)) { X switch (mode) { X case 'I': X fval = (FLOTYPE)ival; X farg = getflonum(arg); X mode = 'F'; X break; X case 'F': X farg = getflonum(arg); X break; X } X } X else X xlbadtype(arg); X X /* accumulate the result value */ X switch (mode) { X case 'I': X switch (fcn) { X case '+': ival += iarg; break; X case '-': ival -= iarg; break; X case '*': ival *= iarg; break; X case '/': checkizero(iarg); X if ((ival % iarg) == 0) X ival /= iarg; X else { X fval = (FLOTYPE)ival; X farg = (FLOTYPE)iarg; X fval /= farg; X mode = 'F'; X } X break; X case 'Q': checkizero(iarg); ival /= iarg; break; X case 'R': checkizero(iarg); ival %= iarg; break; X case 'M': if (iarg > ival) ival = iarg; break; X case 'm': if (iarg < ival) ival = iarg; break; X case 'E': return (cvflonum((FLOTYPE)pow((FLOTYPE)ival,(FLOTYPE)iarg))); X case '&': ival &= iarg; break; X case '|': ival |= iarg; break; X case '^': ival ^= iarg; break; X default: badiop(); X } X break; X case 'F': X switch (fcn) { X case '+': fval += farg; break; X case '-': fval -= farg; break; X case '*': fval *= farg; break; X case '/': checkfzero(farg); fval /= farg; break; X case 'M': if (farg > fval) fval = farg; break; X case 'm': if (farg < fval) fval = farg; break; X case 'E': fval = pow(fval,farg); break; X default: badfop(); X } X break; X } X } X X /* return the result */ X switch (mode) { X case 'I': return (cvfixnum(ival)); X case 'F': return (cvflonum(fval)); X } X} X X/* unary functions */ XLVAL xlognot() { return (unary('~')); } /* lognot */ XLVAL xabs() { return (unary('A')); } /* abs */ XLVAL xadd1() { return (unary('+')); } /* 1+ */ XLVAL xsub1() { return (unary('-')); } /* -1+ */ XLVAL xsin() { return (unary('S')); } /* sin */ XLVAL xcos() { return (unary('C')); } /* cos */ XLVAL xtan() { return (unary('T')); } /* tan */ XLVAL xasin() { return (unary('s')); } /* asin */ XLVAL xacos() { return (unary('c')); } /* acos */ XLVAL xxexp() { return (unary('E')); } /* exp */ XLVAL xsqrt() { return (unary('R')); } /* sqrt */ XLVAL xxlog() { return (unary('L')); } /* log */ XLVAL xrandom() { return (unary('?')); } /* random */ X X/* unary - handle unary operations */ XLOCAL LVAL unary(fcn) X int fcn; X{ X FLOTYPE fval; X FIXTYPE ival; X LVAL arg; X X /* get the argument */ X arg = xlgetarg(); X xllastarg(); X X /* check its type */ X if (fixp(arg)) { X ival = getfixnum(arg); X switch (fcn) { X case '~': ival = ~ival; break; X case 'A': ival = (ival < 0 ? -ival : ival); break; X case '+': ival++; break; X case '-': ival--; break; X case 'S': return (cvflonum((FLOTYPE)sin((FLOTYPE)ival))); X case 'C': return (cvflonum((FLOTYPE)cos((FLOTYPE)ival))); X case 'T': return (cvflonum((FLOTYPE)tan((FLOTYPE)ival))); X case 's': return (cvflonum((FLOTYPE)asin((FLOTYPE)ival))); X case 'c': return (cvflonum((FLOTYPE)acos((FLOTYPE)ival))); X case 't': return (cvflonum((FLOTYPE)atan((FLOTYPE)ival))); X case 'E': return (cvflonum((FLOTYPE)exp((FLOTYPE)ival))); X case 'L': return (cvflonum((FLOTYPE)log((FLOTYPE)ival))); X case 'R': checkineg(ival); X return (cvflonum((FLOTYPE)sqrt((FLOTYPE)ival))); X case '?': ival = (FIXTYPE)osrand((int)ival); break; X default: badiop(); X } X return (cvfixnum(ival)); X } X else if (floatp(arg)) { X fval = getflonum(arg); X switch (fcn) { X case 'A': fval = (fval < 0.0 ? -fval : fval); break; X case '+': fval += 1.0; break; X case '-': fval -= 1.0; break; X case 'S': fval = sin(fval); break; X case 'C': fval = cos(fval); break; X case 'T': fval = tan(fval); break; X case 's': fval = asin(fval); break; X case 'c': fval = acos(fval); break; X case 't': fval = atan(fval); break; X case 'E': fval = exp(fval); break; X case 'L': fval = log(fval); break; X case 'R': checkfneg(fval); X fval = sqrt(fval); break; X default: badfop(); X } X return (cvflonum(fval)); X } X else X xlbadtype(arg); X} X X/* xgcd - greatest common divisor */ XLVAL xgcd() X{ X FIXTYPE m,n,r; X LVAL arg; X X if (!moreargs()) /* check for identity case */ X return (cvfixnum((FIXTYPE)0)); X arg = xlgafixnum(); X n = getfixnum(arg); X if (n < (FIXTYPE)0) n = -n; /* absolute value */ X while (moreargs()) { X arg = xlgafixnum(); X m = getfixnum(arg); X if (m < (FIXTYPE)0) m = -m; /* absolute value */ X for (;;) { /* euclid's algorithm */ X r = m % n; X if (r == (FIXTYPE)0) X break; X m = n; X n = r; X } X } X return (cvfixnum(n)); X} X X/* unary predicates */ XLVAL xnegativep() { return (predicate('-')); } /* negative? */ XLVAL xzerop() { return (predicate('Z')); } /* zero? */ XLVAL xpositivep() { return (predicate('+')); } /* positive? */ XLVAL xevenp() { return (predicate('E')); } /* even? */ XLVAL xoddp() { return (predicate('O')); } /* odd? */ X X/* predicate - handle a predicate function */ XLOCAL LVAL predicate(fcn) X int fcn; X{ X FLOTYPE fval; X FIXTYPE ival; X LVAL arg; X X /* get the argument */ X arg = xlgetarg(); X xllastarg(); X X /* check the argument type */ X if (fixp(arg)) { X ival = getfixnum(arg); X switch (fcn) { X case '-': ival = (ival < 0); break; X case 'Z': ival = (ival == 0); break; X case '+': ival = (ival > 0); break; X case 'E': ival = ((ival & 1) == 0); break; X case 'O': ival = ((ival & 1) != 0); break; X default: badiop(); X } X } X else if (floatp(arg)) { X fval = getflonum(arg); X switch (fcn) { X case '-': ival = (fval < 0); break; X case 'Z': ival = (fval == 0); break; X case '+': ival = (fval > 0); break; X default: badfop(); X } X } X else X xlbadtype(arg); X X /* return the result value */ X return (ival ? true : NIL); X} X X/* comparison functions */ XLVAL xlss() { return (compare('<')); } /* < */ XLVAL xleq() { return (compare('L')); } /* <= */ XLVAL xeql() { return (compare('=')); } /* = */ XLVAL xgeq() { return (compare('G')); } /* >= */ XLVAL xgtr() { return (compare('>')); } /* > */ X X/* compare - common compare function */ XLOCAL LVAL compare(fcn) X int fcn; X{ X FIXTYPE icmp,ival,iarg; X FLOTYPE fcmp,fval,farg; X LVAL arg; X int mode; X X /* get the first argument */ X arg = xlgetarg(); X X /* set the type of the first argument */ X if (fixp(arg)) { X ival = getfixnum(arg); X mode = 'I'; X } X else if (floatp(arg)) { X fval = getflonum(arg); X mode = 'F'; X } X else X xlbadtype(arg); X X /* handle each remaining argument */ X for (icmp = TRUE; icmp && moreargs(); ival = iarg, fval = farg) { X X /* get the next argument */ X arg = xlgetarg(); X X /* check its type */ X if (fixp(arg)) { X switch (mode) { X case 'I': X iarg = getfixnum(arg); X break; X case 'F': X farg = (FLOTYPE)getfixnum(arg); X break; X } X } X else if (floatp(arg)) { X switch (mode) { X case 'I': X fval = (FLOTYPE)ival; X farg = getflonum(arg); X mode = 'F'; X break; X case 'F': X farg = getflonum(arg); X break; X } X } X else X xlbadtype(arg); X X /* compute result of the compare */ X switch (mode) { X case 'I': X icmp = ival - iarg; X switch (fcn) { X case '<': icmp = (icmp < 0); break; X case 'L': icmp = (icmp <= 0); break; X case '=': icmp = (icmp == 0); break; X case 'G': icmp = (icmp >= 0); break; X case '>': icmp = (icmp > 0); break; X } X break; X case 'F': X fcmp = fval - farg; X switch (fcn) { X case '<': icmp = (fcmp < 0.0); break; X case 'L': icmp = (fcmp <= 0.0); break; X case '=': icmp = (fcmp == 0.0); break; X case 'G': icmp = (fcmp >= 0.0); break; X case '>': icmp = (fcmp > 0.0); break; X } X break; X } X } X X /* return the result */ X return (icmp ? true : NIL); X} X X/* toflotype - convert a lisp value to a floating point number */ XFLOTYPE toflotype(val) X LVAL val; X{ X /* must be a number for this to work */ X switch (ntype(val)) { X case FIXNUM: return ((FLOTYPE)getfixnum(val)); X case FLONUM: return (getflonum(val)); X } X} X X/* checkizero - check for integer division by zero */ Xcheckizero(iarg) X FIXTYPE iarg; X{ X if (iarg == 0) X xlfail("division by zero"); X} X X/* checkineg - check for square root of a negative number */ Xcheckineg(iarg) X FIXTYPE iarg; X{ X if (iarg < 0) X xlfail("square root of a negative number"); X} X X/* checkfzero - check for floating point division by zero */ Xcheckfzero(farg) X FLOTYPE farg; X{ X if (farg == 0.0) X xlfail("division by zero"); X} X X/* checkfneg - check for square root of a negative number */ Xcheckfneg(farg) X FLOTYPE farg; X{ X if (farg < 0.0) X xlfail("square root of a negative number"); X} X X/* badiop - bad integer operation */ XLOCAL badiop() X{ X xlfail("bad integer operation"); X} X X/* badfop - bad floating point operation */ XLOCAL badfop() X{ X xlfail("bad floating point operation"); X} END_OF_FILE if test 13437 -ne `wc -c <'Src/xsmath.c'`; then echo shar: \"'Src/xsmath.c'\" unpacked with wrong size! fi # end of 'Src/xsmath.c' fi echo shar: End of archive 3 $of 7$. cp /dev/null ark3isdone MISSING="" for I in 1 2 3 4 5 6 7 ; do if test ! -f ark${I}isdone ; then MISSING="${MISSING} ${I}" fi done if test "${MISSING}" = "" ; then echo You have unpacked all 7 archives. rm -f ark[1-9]isdone else echo You still need to unpack the following archives: echo " " ${MISSING} fi ## End of shell archive. exit 0 -- Mail submissions (sources or binaries) to <amiga@cs.odu.edu>. Mail comments to the moderator at <amiga-request@cs.odu.edu>. Post requests for sources, and general discussion to comp.sys.amiga.